home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / bxfile.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  14.8 KB  |  392 lines
  1. ;; -*- Mode: LISP; PACKAGE: (BOXER GLOBAL 1000); BASE: 8.; FONTS: cptfont -*-
  2. ;;
  3. ;; (C) Copyright 1983-1985 Massachusetts Institute of Technology
  4. ;;
  5. ;; Permission to use, copy, modify, distribute, and sell this software
  6. ;; and its documentation for any purpose is hereby granted without fee,
  7. ;; provided that the above copyright notice appear in all copies and that
  8. ;; both that copyright notice and this permission notice appear in
  9. ;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;; advertising or publicity pertaining to distribution of the software
  11. ;; without specific, written prior permission.  M.I.T. makes no
  12. ;; representations about the suitability of this software for any
  13. ;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;
  15. ;;
  16. ;;                          +-Data--+
  17. ;; This file is part of the | BOXER | system.
  18. ;;                          +-------+
  19. ;;
  20.  
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22. ;;;;              THIS  IS  THE  FILE  SYSTEM  INTERFACE  FOR  BOXER                      ;;;;
  23. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24. ;;;
  25.  
  26. ;;; This file contains the top level interface between the BOXER file system and the rest
  27. ;;; of the BOXER system
  28. ;;; Most of the rest of this file contains old versions of the file system code so that OLD
  29. ;;; BOXER code can still be used. 
  30.  
  31. ;;; Low level conversion methods for boxes and rows (and chas)
  32. ;;; these functions convert between the current box representation and
  33. ;;; the two styles of file reprsentation for boxes/rows
  34. ;;; these two styles being: LIST-STYLE and ARRAY-STYLE
  35.  
  36. ;;; BOX =====> FILE functions................
  37.  
  38. (DEFMETHOD (BOX :RETURN-INIT-PLIST-FOR-SAVING) ()
  39.   `(:TYPE ,(TELL SELF :TYPE)
  40.     :DISPLAY-STYLE-LIST ,DISPLAY-STYLE-LIST
  41.     :TRUE-NAME ,(UNLESS (NULL PORTS)
  42.           (PUTHASH SELF (INTERN (GENSYM)) *PORT-HASH-TABLE*))))
  43.  
  44. (DEFMETHOD (PORT-BOX :RETURN-INIT-PLIST-FOR-SAVING) ()
  45.   `(:TYPE ,(TELL SELF :TYPE)
  46.     :DISPLAY-STYLE-LIST ,DISPLAY-STYLE-LIST
  47.     :PORTED-TO-BOX ,(GETHASH PORTS *PORT-HASH-TABLE*)))
  48.  
  49. ;;;rows are converted to leaderless arrays (or lists of chas/box-lists) for storage
  50.  
  51. (DEFMETHOD (ROW :RETURN-ARRAY-FOR-STORAGE) ()
  52.   (LET* ((LAST-CHA (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY))
  53.      (ROW-STORAGE-ARRAY (MAKE-ARRAY LAST-CHA)))
  54.     (DO ((CHA-INDEX 0 (+ CHA-INDEX 1)))
  55.     ((= CHA-INDEX LAST-CHA) ROW-STORAGE-ARRAY)
  56.       (ASET (IF (BOX? (AREF CHAS-ARRAY CHA-INDEX))
  57.         (TELL (AREF CHAS-ARRAY CHA-INDEX) :RETURN-ARRAY-FOR-STORAGE)
  58.         (AREF CHAS-ARRAY CHA-INDEX))    ;goes away when we flush chas
  59.         ROW-STORAGE-ARRAY
  60.         CHA-INDEX))))
  61.  
  62. (DEFMETHOD (ROW :RETURN-LIST-FOR-STORAGE) ()    ;is this faster ?
  63.   (MAPCAR (FUNCTION (LAMBDA (CHA) (IF (BOX? CHA)
  64.                       (TELL CHA :RETURN-LIST-FOR-STORAGE)
  65.                       CHA)))
  66.       (TELL SELF :CHAS)))
  67.     
  68.  
  69. ;;;boxes are converted to an array of row arrays with the init-plist-for-saving store in 
  70. ;;;the leader of the array or a list of row lists with the plist as the car
  71.  
  72. (DEFMETHOD (BOX :RETURN-ARRAY-FOR-STORAGE) ()
  73.   (LET* ((LAST-ROW (TELL SELF :LENGTH-IN-ROWS))
  74.      (BOX-STORAGE-ARRAY (MAKE-ARRAY LAST-ROW
  75.                     ':LEADER-LIST
  76.                     `(,(TELL SELF :RETURN-INIT-PLIST-FOR-SAVING)))))
  77.     (DO ((ROW-INDEX 0 (+ ROW-INDEX 1)))
  78.     ((= ROW-INDEX LAST-ROW) BOX-STORAGE-ARRAY)
  79.       (ASET (TELL (TELL SELF :ROW-AT-ROW-NO ROW-INDEX) :RETURN-ARRAY-FOR-STORAGE)
  80.         BOX-STORAGE-ARRAY
  81.         ROW-INDEX))))
  82.  
  83. (DEFMETHOD (PORT-BOX :RETURN-ARRAY-FOR-STORAGE) ()
  84.   (MAKE-ARRAY 0 ':LEADER-LIST `(,(TELL SELF :RETURN-INIT-PLIST-FOR-SAVING))))
  85.  
  86. (DEFMETHOD (BOX :RETURN-LIST-FOR-STORAGE) ()
  87.   (CONS (TELL SELF :RETURN-INIT-PLIST-FOR-SAVING)
  88.     (MAPCAR (FUNCTION (LAMBDA (ROW) (TELL ROW :RETURN-LIST-FOR-STORAGE)))
  89.         (TELL SELF :ROWS))))
  90.  
  91. (DEFMETHOD (PORT-BOX :RETURN-LIST-FOR-STORAGE) ()
  92.   (CONS (TELL SELF :RETURN-INIT-PLIST-FOR-SAVING)
  93.     ()))
  94.  
  95.  
  96. ;;;FILE =====> BOX functions................
  97.  
  98. (DEFMETHOD (BOX :INIT-FROM-FILE) (INIT-PLIST)
  99.   (SETQ ;;these come from box proper
  100.     CACHED-ROWS        NIL
  101.     CACHED-CODE        NIL
  102.     DISPLAY-STYLE-LIST (OR (GET INIT-PLIST ':DISPLAY-STYLE-LIST)
  103.                DISPLAY-STYLE-LIST))
  104.   (TELL SELF :SET-TYPE (OR (GET INIT-PLIST ':TYPE) ':DOIT-BOX))
  105.   (UNLESS (NULL (GET INIT-PLIST ':TRUE-NAME))    ;if there is a TRUE-NAME hash it with the box
  106.     (PUSH SELF *RENAME-QUEUE*)            ;get a new name to avoid conflicts
  107.     (PUTHASH (GET INIT-PLIST ':TRUE-NAME) SELF *FILE-PORT-HASH-TABLE*)))
  108.  
  109.  
  110. ;(DEFMETHOD (GRAPHICS-BOX :INIT-FROM-FILE) (INIT-PLIST)
  111. ;  (MULTIPLE-VALUE-BIND (IL IT IR IB)
  112. ;      (WITH-FONT-MAP-BOUND (*BOXER-PANE*)
  113. ;    (BOX-BORDERS-FN ':BORDER-WIDS ':GRAPHICS-BOX))
  114. ;    (LET ((HOR-BORDER-SIZE (+ IL IR))
  115. ;      (VER-BORDER-SIZE (+ IT IB)))
  116. ;      (SETQ ;; These we inherit from chas.
  117. ;    SUPERIOR-ROW       (GET INIT-PLIST ':SUPERIOR-ROW)
  118. ;    CHA-CODE           ':BOX
  119. ;    FONT-NO            NIL
  120. ;    ;; these we inherit from vanilla boxes
  121. ;    FIRST-INFERIOR-ROW NIL
  122. ;    CACHED-ROWS        NIL
  123. ;    CACHED-CODE        NIL
  124. ;    STATIC-VARIABLES-ALIST NIL
  125. ;    DISPLAY-STYLE-LIST (OR (GET INIT-PLIST ':DISPLAY-STYLE-LIST)
  126. ;                   DISPLAY-STYLE-LIST)
  127. ;    ;; and this is from the graphics box itself
  128. ;    BIT-ARRAY          (TV:MAKE-SHEET-BIT-ARRAY
  129. ;                 *BOXER-PANE*
  130. ;                 (- (CADR DISPLAY-STYLE-LIST) HOR-BORDER-SIZE)
  131. ;                 (- (CADDR DISPLAY-STYLE-LIST) VER-BORDER-SIZE)
  132. ;                 ':TYPE 'ART-1B
  133. ;                 ;; we need to store the actual desired width of the bit
  134. ;                 ;; array in the leader because TV:MAKE-SHEET-BIT-ARRAY
  135. ;                 ;; rounds up to the nearest multiple of 32 in order to
  136. ;                 ;; keep BITBLT happy
  137. ;                 ':LEADER-LIST `(,(- (CADR DISPLAY-STYLE-LIST) HOR-BORDER-SIZE)
  138. ;                         ,(- (CADDR DISPLAY-STYLE-LIST) VER-BORDER-SIZE)))))))
  139.  
  140.  
  141. (DEFMETHOD (BOX :FILL-FROM-STORAGE-ARRAY) (STORAGE-ARRAY)
  142.   (LET ((NO-OF-ROWS (ARRAY-LENGTH STORAGE-ARRAY)))
  143.     (SETQ FIRST-INFERIOR-ROW (MAKE-A-ROW-FROM-ARRAY-STORAGE SELF (AREF STORAGE-ARRAY 0)))
  144.     (DOTIMES (ROW-NO (1- NO-OF-ROWS))
  145.       (TELL SELF :APPEND-ROW
  146.         (MAKE-A-ROW-FROM-ARRAY-STORAGE SELF (AREF STORAGE-ARRAY (1+ ROW-NO)))))))
  147.  
  148. (DEFMETHOD (BOX :FILL-FROM-STORAGE-LIST) (STORAGE-LIST)    ;takes a list of rows (no plist)
  149.   (SETQ FIRST-INFERIOR-ROW (MAKE-A-ROW-FROM-LIST-STORAGE SELF (CAR STORAGE-LIST)))
  150.   (DOLIST (ROW-LIST (CDR STORAGE-LIST))
  151.     (TELL SELF :APPEND-ROW
  152.       (MAKE-A-ROW-FROM-LIST-STORAGE SELF ROW-LIST))))
  153.  
  154. (DEFMETHOD (PORT-BOX :FILL-FROM-STORAGE-ARRAY) (STORAGE-ARRAY)
  155.   STORAGE-ARRAY
  156.   NIL)
  157.  
  158. (DEFMETHOD (PORT-BOX :FILL-FROM-STORAGE-LIST) (STORAGE-LIST)
  159.   STORAGE-LIST
  160.   NIL)
  161.  
  162. (DEFUN MAKE-A-BOX-FROM-ARRAY-STORAGE (ROW-IT-IS-IN BOX-ARRAY
  163.                       &OPTIONAL (BOX (MAKE-INSTANCE 'BOX)))
  164.   (LET* ((INIT-PLIST (LOCF (ARRAY-LEADER BOX-ARRAY 0))))
  165.     (TELL BOX :INIT-FROM-FILE INIT-PLIST)
  166.     (TELL BOX :SET-SUPERIOR-ROW ROW-IT-IS-IN)
  167.     (IF (PORT-BOX? BOX)
  168.     (IF (GETHASH (GET INIT-PLIST ':PORTED-TO-BOX) *FILE-PORT-HASH-TABLE*) 
  169.         (TELL BOX :SET-PORT-TO-BOX
  170.           (GETHASH (GET INIT-PLIST ':PORTED-TO-BOX) *FILE-PORT-HASH-TABLE*))
  171.         (PUSH (CONS BOX (GET INIT-PLIST ':PORTED-TO-BOX))
  172.           *FILE-PORT-QUEUE*))        ;ported to box doesn't exist yet
  173.     (TELL BOX :FILL-FROM-STORAGE-ARRAY BOX-ARRAY)))
  174.   BOX)
  175.  
  176. (DEFUN MAKE-A-BOX-FROM-LIST-STORAGE (ROW-IT-IS-IN BOX-LIST
  177.                       &OPTIONAL (BOX (MAKE-INSTANCE 'BOX)))
  178.   (LET* ((INIT-PLIST (LOCF (CAR BOX-LIST))))
  179.     (TELL BOX :SET-SUPERIOR-ROW ROW-IT-IS-IN)
  180.     (TELL BOX :INIT-FROM-FILE INIT-PLIST)
  181.     (WHEN (GRAPHICS-BOX? BOX)
  182.       (SETQ *ROW-CHAS-POINTER-ADJUST* T))
  183.     (IF (PORT-BOX? BOX)
  184.     (IF (GETHASH (GET INIT-PLIST ':PORTED-TO-BOX) *FILE-PORT-HASH-TABLE*) 
  185.         (TELL BOX :SET-PORT-TO-BOX
  186.           (GETHASH (GET INIT-PLIST ':PORTED-TO-BOX) *FILE-PORT-HASH-TABLE*))
  187.         (PUSH (CONS BOX (GET INIT-PLIST ':PORTED-TO-BOX))
  188.           *FILE-PORT-QUEUE*))        ;ported to box doesn't exist yet
  189.     (TELL BOX :FILL-FROM-STORAGE-LIST (CDR BOX-LIST))))
  190.   BOX)
  191.  
  192. ;;when chas get flushed, this should change todo the boxes in the array and then
  193. ;;do a copy array
  194.  
  195. (DEFMETHOD (ROW :FILL-FROM-STORAGE-ARRAY) (STORAGE-ARRAY)
  196.   (DOTIMES (CHA-NO (ARRAY-LENGTH STORAGE-ARRAY))
  197.     (IF (NUMBERP (AREF STORAGE-ARRAY CHA-NO))
  198.     (CHAS-ARRAY-INSERT-CHA CHAS-ARRAY
  199.                    CHA-NO
  200.                    (AREF STORAGE-ARRAY CHA-NO))
  201.     (CHAS-ARRAY-INSERT-CHA CHAS-ARRAY
  202.                    CHA-NO
  203.                    (MAKE-A-BOX-FROM-ARRAY-STORAGE SELF
  204.                                   (AREF STORAGE-ARRAY CHA-NO))))))
  205.  
  206. (DEFMETHOD (ROW :FILL-FROM-STORAGE-LIST) (STORAGE-LIST)
  207.   (LET ((*ROW-CHAS-POINTER-ADJUST* NIL))
  208.     (DOTIMES (CHA-NO (LENGTH STORAGE-LIST))
  209.       (IF (NUMBERP (NTH CHA-NO STORAGE-LIST))
  210.       (CHAS-ARRAY-INSERT-CHA CHAS-ARRAY
  211.                  CHA-NO
  212.                  (NTH CHA-NO STORAGE-LIST))
  213.       (CHAS-ARRAY-INSERT-CHA CHAS-ARRAY
  214.                  CHA-NO
  215.                  (MAKE-A-BOX-FROM-LIST-STORAGE SELF
  216.                                    (NTH CHA-NO STORAGE-LIST)))))
  217.     (WHEN *ROW-CHAS-POINTER-ADJUST*
  218.       (DOTIMES (I (TELL SELF :LENGTH-IN-CHAS))
  219.     (SETF (AREF CHAS-ARRAY I)
  220.           (FOLLOW-STRUCTURE-FORWARDING (AREF CHAS-ARRAY I)))))))
  221.  
  222. (DEFUN MAKE-A-ROW-FROM-ARRAY-STORAGE (BOX-IT-IS-IN ROW-ARRAY)
  223.   (LET ((NEW-ROW (MAKE-INSTANCE 'ROW)))
  224.     (TELL NEW-ROW :SET-SUPERIOR-BOX BOX-IT-IS-IN)
  225.     (TELL NEW-ROW :FILL-FROM-STORAGE-ARRAY ROW-ARRAY)
  226.     NEW-ROW))
  227.  
  228. (DEFUN MAKE-A-ROW-FROM-LIST-STORAGE (BOX-IT-IS-IN ROW-LIST)
  229.   (LET ((NEW-ROW (MAKE-INSTANCE 'ROW)))
  230.     (TELL NEW-ROW :SET-SUPERIOR-BOX BOX-IT-IS-IN)
  231.     (TELL NEW-ROW :FILL-FROM-STORAGE-LIST ROW-LIST)
  232.     NEW-ROW))
  233.  
  234. (DEFUN MAKE-A-CHA-FROM-STORAGE (CHA-CODE-NO)
  235.   (MAKE-CHA CHA-CODE-NO))
  236.  
  237.  
  238.  
  239. (DEFUN DO-QUEUED-PORTS ()
  240.   (DOLIST (PORT-WITH-DESTINATION *FILE-PORT-QUEUE*)
  241.     (TELL (CAR PORT-WITH-DESTINATION) :SET-PORT-TO-BOX
  242.       (GETHASH (CDR PORT-WITH-DESTINATION) *FILE-PORT-HASH-TABLE*))))
  243.  
  244. (COMMENT                    ;flush when the fasdumper works
  245. (DEFUN RENAME-RENAME-QUEUE ()
  246.   (DOLIST (BOX-THAT-NEEDS-A-NEW-NAME *RENAME-QUEUE*)
  247.     (TELL BOX-THAT-NEEDS-A-NEW-NAME :CHANGE-TRUE-NAME)))
  248. )                        ;to here
  249.  
  250. ;;;Slow, portable save/read box....
  251.  
  252. (DEFUN SAVE-BOX-INTO-FILE-INTERNAL (BOX NAME)
  253.   (WITH-OPEN-FILE
  254.     (FILE-STREAM NAME ':OUT)
  255.     (FUNCALL FILE-STREAM ':LINE-OUT ";-*-MODE:BOXER; -*-")
  256.     (FUNCALL FILE-STREAM ':LINE-OUT "(SETQ *BOX-STORAGE-LIST* (QUOTE ")
  257.     (LET ((PACKAGE (PKG-FIND-PACKAGE 'BOXER))
  258.       (BASE 10.)
  259.       (IBASE 10.)
  260.       (*NOPOINT NIL))
  261.       (PRIN1 (TELL BOX :RETURN-LIST-FOR-STORAGE) FILE-STREAM))
  262.     (FUNCALL FILE-STREAM ':LINE-OUT "))"))
  263.   (CLRHASH *PORT-HASH-TABLE*)
  264.   ':NOPRINT)
  265.  
  266. (DEFUN READ-FILE-INTO-BOX-INTERNAL (EMPTY-BOX NAME)
  267.   (LET ((BASE 10.)
  268.     (IBASE 10.)
  269.     (*NOPOINT NIL))
  270.   (READFILE NAME 'BOXER T))
  271.   ;;the variable *BOX-STORAGE-LIST* is now defined
  272.   (MAKE-A-BOX-FROM-LIST-STORAGE (TELL EMPTY-BOX :SUPERIOR-ROW)
  273.                  *BOX-STORAGE-LIST*
  274.                  EMPTY-BOX)
  275.   (DO-QUEUED-PORTS)                  ;take care of any ports that have been deferred
  276.   (CLRHASH *FILE-PORT-HASH-TABLE*)          ;clear hash table for next read
  277. ;  (RENAME-RENAME-QUEUE)               ;rename all boxes with names to avoid possible
  278.   (PROCESS-BOX-LOCAL-DEFINITIONS EMPTY-BOX))  ;name conflicts with already existing boxes  
  279.  
  280. ;;; The Top Level.  This looks at the :byte-size property to determine if the file has been
  281. ;;; fasdumped or if it is a simple list
  282.  
  283. (DEFUN READ-FILE-INTO-BOX (EMPTY-BOX NAME)
  284.   (LET* ((PATHNAME (IF *STICKY-FILE-DEFAULTING?*
  285.                (SETQ *BOXER-PATHNAME-DEFAULT*
  286.                  (FS:MERGE-PATHNAMES NAME *BOXER-PATHNAME-DEFAULT*))
  287.                (FS:MERGE-PATHNAMES NAME *BOXER-PATHNAME-DEFAULT*)))
  288.      (BYTE-SIZE (GET (FS:FILE-PROPERTIES PATHNAME) ':BYTE-SIZE)))
  289.     (IF (> BYTE-SIZE 7.)
  290.     (LOAD-BINARY-BOX-INTERNAL EMPTY-BOX PATHNAME)
  291.     (READ-FILE-INTO-BOX-INTERNAL EMPTY-BOX PATHNAME)))
  292.   (TELL EMPTY-BOX :MODIFIED))
  293.  
  294. (DEFUN SAVE-BOX-INTO-FILE (BOX FILENAME)
  295.   (LET ((PATHNAME (IF *STICKY-FILE-DEFAULTING?*
  296.                (SETQ *BOXER-PATHNAME-DEFAULT*
  297.                  (FS:MERGE-PATHNAMES FILENAME *BOXER-PATHNAME-DEFAULT*))
  298.                (FS:MERGE-PATHNAMES FILENAME *BOXER-PATHNAME-DEFAULT*))))
  299.     (when (cl:probe-file pathname)
  300.       (cl:rename-file pathname
  301.               (cl:make-pathname :name
  302.                     (cl:string
  303.                       (string-append (send pathname :name)
  304.                              "-OLD"))
  305.                     :defaults
  306.                     pathname)))
  307.     (IF *FASDUMP?*
  308.     (DUMP-TOP-LEVEL-BOX BOX PATHNAME)
  309.     (SAVE-BOX-INTO-FILE-INTERNAL BOX PATHNAME))))
  310.  
  311. (DEFUN INITIALIZE-BOXER-WORLD ()
  312.   (COND ((PROBEF (FS:INIT-FILE-PATHNAME "BOXER" :BIN))
  313.      (LOAD (FS:INIT-FILE-PATHNAME "BOXER" :BIN)))
  314.     ((PROBEF (FS:INIT-FILE-PATHNAME "BOXER" :LISP))
  315.      (LOAD (FS:INIT-FILE-PATHNAME "BOXER" :LISP))))
  316.   (WHEN (PROBEF (FS:INIT-FILE-PATHNAME "BOXER" :BOX))
  317.     (LET ((*STICKY-FILE-DEFAULTING?* NIL))
  318.       (READ-FILE-INTO-BOX
  319.     *INITIAL-BOX*
  320.     (FS:INIT-FILE-PATHNAME "BOXER" :BOX)))))
  321.  
  322. (DEFUN INITIALIZE-BOXER-FROM-LISP ()
  323.   (WHEN (BOUNDP '*BOXER-PANE*)
  324.     (SETUP-EDITOR T)))
  325.  
  326. ;;;stuff from streams--we need to keep this around so that we can load old
  327. ;;;boxer code
  328.  
  329. (DEFUN STREAM-COPY-UNTIL (IN OUT FN)
  330.   (DO ((PEEK (TELL IN :TYIPEEK) (TELL IN :TYIPEEK)))
  331.       ((OR (NULL PEEK) (FUNCALL FN PEEK)))
  332.     (TELL OUT :TYO (TELL IN :TYI))))
  333.  
  334. (DEFUN EAT-STREAM-UNTIL (INSTREAM FUNCTION)
  335.   (DO ((INPUT (FUNCALL INSTREAM ':TYIPEEK) (FUNCALL INSTREAM ':TYIPEEK)))
  336.       ((OR (NULL INPUT) (FUNCALL FUNCTION INPUT)))
  337.     (FUNCALL INSTREAM ':TYI)))
  338.  
  339. (DEFUN OLD-WRITE-BOX-INTO-FILE (FROM-BOX FILENAME)
  340.   (WITH-OPEN-FILE
  341.     (FILE-STREAM (FS:MERGE-PATHNAMES FILENAME *BOXER-PATHNAME-DEFAULT*) ':OUT)
  342.     (LET ((BOX-STREAM (MAKE-BOX-STREAM FROM-BOX)))
  343.       (FUNCALL FILE-STREAM ':LINE-OUT "-*- MODE: BOXER; -*-")
  344.       (STREAM-COPY-UNTIL-EOF BOX-STREAM FILE-STREAM)
  345.       ':NOPRINT)))
  346.  
  347. (DEFUN OLD-READ-FILE-INTO-BOX (TO-BOX FILENAME)
  348.   (WITH-OPEN-FILE (INSTREAM (FS:MERGE-PATHNAMES FILENAME *BOXER-PATHNAME-DEFAULT*))
  349.     (LET ((FILE-ATTRIBUTES (FS:READ-ATTRIBUTE-LIST (FUNCALL INSTREAM ':PATHNAME) INSTREAM)))
  350.       (COND ((NEQ (CADR (MEMQ ':MODE FILE-ATTRIBUTES)) ':BOXER)
  351.          (FERROR "READ-FILE-INTO-BOX works only for BOXER files"))
  352.         (T
  353.          (EAT-STREAM-UNTIL INSTREAM #'STRT-BOX-CODE?)
  354.          (TELL TO-BOX :SET-CONTENTS-FROM-STREAM INSTREAM))))
  355.     (PROCESS-BOX-LOCAL-DEFINITIONS TO-BOX)
  356.     ':NOPRINT))
  357.  
  358. (DEFUN FIX-BOXER-FILE (INFILE OUTFILE)
  359.   (WITH-OPEN-FILE (INSTREAM INFILE)
  360.     (WITH-OPEN-FILE (OUTSTREAM OUTFILE ':OUT)
  361.       (FUNCALL INSTREAM ':LINE-IN)
  362.       (FUNCALL OUTSTREAM ':LINE-OUT "-*- MODE: BOXER; -*-")
  363.       (FIX-BOXER-FILE-1 INSTREAM OUTSTREAM))))
  364.  
  365. (DEFUN FIX-BOXER-FILE-1 (INSTREAM OUTSTREAM)
  366.   (DO ()
  367.       ((NOT (TELL INSTREAM :LISTEN)))
  368.     (STREAM-COPY-UNTIL INSTREAM OUTSTREAM
  369.       #'(LAMBDA (X) (MEMQ X '(#\ROMAN-I #\ROMAN-II #\ROMAN-III))))
  370.     (SELECTQ (TELL INSTREAM :TYI)
  371.       (#\ROMAN-I
  372.        (TELL OUTSTREAM :TYO *STRT-BOX-CODE*)
  373.        (FORMAT OUTSTREAM "~:S" (READ INSTREAM))
  374.        (TELL OUTSTREAM :TYO *STRT-ROW-CODE*))
  375.       (#\ROMAN-II
  376.        (TELL OUTSTREAM :TYO *STOP-ROW-CODE*)
  377.        (TELL OUTSTREAM :TYO *STOP-BOX-CODE*))
  378.       (#\ROMAN-III
  379.        (TELL OUTSTREAM :TYO *STOP-ROW-CODE*)
  380.        (TELL OUTSTREAM :TYO *STRT-ROW-CODE*)))))
  381.  
  382. ;;;interface for the old versions of read/save
  383.  
  384. (DEFBOXER-FUNCTION BU:OLD-SAVE (FROM-BOX FILENAME)
  385.   (CHECK-DATA-BOX-ARG FILENAME)
  386.   (OLD-WRITE-BOX-INTO-FILE FROM-BOX (TELL FILENAME :TEXT-STRING)))
  387.  
  388. (DEFBOXER-FUNCTION BU:OLD-READ (TO-BOX FILENAME)
  389.   (OLD-READ-FILE-INTO-BOX TO-BOX (TELL FILENAME :TEXT-STRING)))
  390.  
  391. (DEFF PROCESS-BOX-LOCAL-DEFINITIONS 'IGNORE)
  392.